home *** CD-ROM | disk | FTP | other *** search
/ Australian Personal Computer 2002 November / CD 1 / APC0211D1.ISO / workshop / prog / files / ActivePerl-5.6.1.633-MSWin32.msi / _ad4cae82408f5dd8a46971d69b66197c < prev    next >
Encoding:
Text File  |  2002-05-30  |  1.6 KB  |  89 lines
  1. # Copyright (c) 1995-1999 Nick Ing-Simmons. All rights reserved.
  2. # This program is free software; you can redistribute it and/or
  3. # modify it under the same terms as Perl itself.
  4. package Tk::After;
  5. use Carp;
  6.  
  7. use vars qw($VERSION);
  8. $VERSION = '3.015'; # $Id: //depot/Tk8/Tk/After.pm#15 $
  9.  
  10. sub _cancelAll
  11. {    
  12.  my $w = shift;
  13.  my $h = delete $w->{_After_};
  14.  foreach my $obj (values %$h)
  15.   {
  16.    # carp "Auto cancel ".$obj->[1]." for ".$obj->[0]->PathName;
  17.    $obj->cancel;
  18.   }
  19. }
  20.  
  21. sub submit
  22. {
  23.  my $obj     = shift;
  24.  my $w       = $obj->[0];
  25.  my $id      = $obj->[1];
  26.  my $t       = $obj->[2];
  27.  my $method  = $obj->[3];
  28.  delete($w->{_After_}{$id}) if (defined $id);
  29.  $id  = $w->Tk::after($t,[$method => $obj]);
  30.  unless (exists $w->{_After_})
  31.   {
  32.    $w->{_After_} = {};
  33.    $w->OnDestroy([\&_cancelAll, $w]);
  34.   }
  35.  $w->{_After_}{$id} = $obj;
  36.  $obj->[1] = $id;
  37.  return $obj;
  38. }
  39.  
  40. sub DESTROY
  41. {
  42.  my $obj = shift;
  43.  @{$obj} = ();
  44. }
  45.  
  46. sub new
  47. {
  48.  my ($class,$w,$t,$method,@cb) = @_;
  49.  my $cb    = (@cb == 1) ? shift(@cb) : [@cb];
  50.  my $obj   = bless [$w,undef,$t,$method,Tk::Callback->new($cb)],$class;
  51.  return $obj->submit;
  52. }
  53.  
  54. sub cancel
  55. {
  56.  my $obj = shift;
  57.  my $id  = $obj->[1];
  58.  my $w   = $obj->[0];
  59.  if ($id)
  60.   {
  61.    $w->Tk::after('cancel'=> $id);
  62.    delete $w->{_After_}{$id} if exists $w->{_After_};
  63.    $obj->[1] = undef;
  64.   }
  65.  return $obj;
  66. }
  67.  
  68. sub repeat
  69. {
  70.  my $obj = shift;
  71.  $obj->submit;
  72.  local $Tk::widget = $obj->[0];
  73.  $obj->[4]->Call;
  74. }
  75.  
  76. sub once
  77. {
  78.  my $obj = shift;
  79.  my $w   = $obj->[0];
  80.  my $id  = $obj->[1];
  81.  delete $w->{_After_}{$id};
  82.  local $Tk::widget = $w;
  83.  $obj->[4]->Call;
  84. }
  85.  
  86. 1;
  87. __END__
  88.  
  89.